home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / comp / compile.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  34.0 KB  |  1,285 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: compile.c,v 1.18 94/10/05 20:54:13 nkramer Exp $
  27. *
  28. * This file generates sequences of byte-ops for each method.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include "../compat/std-c.h"
  33.  
  34. #include "mindycomp.h"
  35. #include "src.h"
  36. #include "dump.h"
  37. #include "lexenv.h"
  38. #include "envanal.h"
  39. #include "sym.h"
  40. #include "literal.h"
  41. #include "compile.h"
  42. #include "byteops.h"
  43. #include "info.h"
  44. #include "lose.h"
  45.  
  46. #define BLOCK_SIZE (4*1024)
  47.  
  48. #define TAIL -1
  49. #define FUNC -2
  50. #define make_want(req,restp) (((req)<<1)|((restp)?1:0))
  51. #define want_req(want) ((want)>>1)
  52. #define want_restp(want) ((want)&1)
  53. #define SINGLE make_want(1,FALSE)
  54. #define NOTHING make_want(0,FALSE)
  55.  
  56. static struct component *compile_method(struct method *method);
  57. static void compile_expr(struct expr *expr, struct component *component,
  58.              int want);
  59. static void compile_body(struct body *body, struct component *component,
  60.              int want);
  61. static void compile_tl_body(struct body *body);
  62.  
  63.  
  64. /* Utilities. */
  65.  
  66. static int current_position(struct component *component)
  67. {
  68.     if (component->cur_block)
  69.     return component->bytes+(component->fill-component->cur_block->bytes);
  70.     else
  71.     return 0;
  72. }
  73.  
  74. static void grow_component(struct component *component)
  75. {
  76.     struct block *block = malloc(BLOCK_SIZE);
  77.     struct block *cur = component->cur_block;
  78.  
  79.     block->next = NULL;
  80.  
  81.     if (cur) {
  82.     cur->next = block;
  83.     cur->end = component->fill;
  84.     component->bytes += cur->end - cur->bytes;
  85.     }
  86.     else if (component->blocks)
  87.     lose("Attempt to add more stuff to a component we were done with?");
  88.     else
  89.     component->blocks = block;
  90.  
  91.     component->cur_block = block;
  92.     component->fill = block->bytes;
  93.     component->end = BLOCK_SIZE + (unsigned char *)block;
  94. }
  95.  
  96. static void emit_byte(struct component *component, int op)
  97. {
  98.     if (component->fill == component->end)
  99.     grow_component(component);
  100.  
  101.     *component->fill++ = op;
  102. }
  103.  
  104. #define emit_op emit_byte
  105.  
  106. static void emit_4bytes(struct component *component, unsigned value)
  107. {
  108.     emit_byte(component, value & 0xff);
  109.     emit_byte(component, (value>>8) & 0xff);
  110.     emit_byte(component, (value>>16) & 0xff);
  111.     emit_byte(component, (value>>24) & 0xff);
  112. }
  113.  
  114. static void emit_op_and_arg(struct component *component, int op, unsigned arg)
  115. {
  116.     if (arg < 0xf)
  117.     emit_byte(component, op|arg);
  118.     else {
  119.     emit_byte(component, op|0xf);
  120.     if (arg < 0xff)
  121.         emit_byte(component, arg);
  122.     else {
  123.         emit_byte(component, 0xff);
  124.         emit_4bytes(component, arg);
  125.     }
  126.     }
  127. }
  128.  
  129. static void emit_call_op_and_arg(struct component *component,
  130.                  int op, unsigned arg)
  131. {
  132.     if (arg < 0xf)
  133.     emit_byte(component, op|arg);
  134.     else {
  135.     emit_byte(component, op|0xf);
  136.     if (arg < 0xff)
  137.         emit_byte(component, arg);
  138.     else {
  139.         emit_byte(component, 0xff);
  140.         emit_4bytes(component, arg);
  141.     }
  142.     emit_byte(component, op);
  143.     }
  144. }
  145.  
  146. static void emit_wants(struct component *component, int want)
  147. {
  148.     if (want == TAIL)
  149.     lose("didn't tail-call when we should?");
  150.     if (want == FUNC)
  151.     lose("calling for multiple values when we want a function?");
  152.  
  153.     if (want < 0xff)
  154.     emit_byte(component, want);
  155.     else {
  156.     emit_byte(component, 0xff);
  157.     emit_4bytes(component, (unsigned)want);
  158.     }
  159. }
  160.  
  161. static unsigned char *reserve_space(struct component *component, int count)
  162. {
  163.     unsigned char *res;
  164.  
  165.     if (component->fill + count > component->end)
  166.     grow_component(component);
  167.     
  168.     res = component->fill;
  169.     component->fill = res + count;
  170.  
  171.     return res;
  172. }
  173.  
  174. static void write_branch_displacement(unsigned char *where, int here,
  175.                       int there)
  176. {
  177.     int disp = there - here;
  178.  
  179.     where[0] = disp & 0xff;
  180.     where[1] = (disp >> 8) & 0xff;
  181.     where[2] = (disp >> 16) & 0xff;
  182.     where[3] = (disp >> 24) & 0xff;
  183. }
  184.  
  185. static void canonicalize_value(struct component *component, int want)
  186. {
  187.     if (want == TAIL)
  188.     emit_op(component, op_RETURN_SINGLE);
  189.     else if (want == FUNC)
  190.     emit_op(component, op_CHECK_TYPE_FUNCTION);
  191.     else if (want != SINGLE) {
  192.     emit_op(component, op_CANONICALIZE_VALUE);
  193.     emit_wants(component, want);
  194.     }
  195. }
  196.  
  197. static int find_literal(struct component *component, struct literal *literal)
  198. {
  199.     int i = 0;
  200.     struct constant *c;
  201.  
  202.     for (c = component->constants; c != NULL; c = c->next)
  203.     if (c->kind == constant_LITERAL && c->u.literal == literal)
  204.         return i;
  205.     else
  206.         i++;
  207.  
  208.     component->nconstants++;
  209.  
  210.     c = malloc(sizeof(struct constant));
  211.     c->kind = constant_LITERAL;
  212.     c->next = NULL;
  213.     c->u.literal = literal;
  214.  
  215.     *component->constants_tail = c;
  216.     component->constants_tail = &c->next;
  217.  
  218.     return i;
  219. }
  220.  
  221. static int find_variable(struct component *component, struct id *id,
  222.              boolean written)
  223. {
  224.     int i = 0;
  225.     struct constant *c;
  226.  
  227.     for (c = component->constants; c != NULL; c = c->next) {
  228.     if (c->kind == constant_VARREF
  229.         && c->u.varref.id->symbol == id->symbol
  230.         && c->u.varref.id->internal == id->internal) {
  231.         if (written)
  232.         c->u.varref.written = TRUE;
  233.         return i;
  234.     }
  235.     else
  236.         i++;
  237.     }
  238.  
  239.     component->nconstants++;
  240.  
  241.     c = malloc(sizeof(struct constant));
  242.     c->kind = constant_VARREF;
  243.     c->next = NULL;
  244.     c->u.varref.id = id;
  245.     c->u.varref.written = written;
  246.  
  247.     *component->constants_tail = c;
  248.     component->constants_tail = &c->next;
  249.  
  250.     return i;
  251. }
  252.  
  253. static int find_method_desc(struct component *component, struct method *method)
  254. {
  255.     struct constant *c;
  256.  
  257.     c = malloc(sizeof(struct constant));
  258.     c->kind = constant_METHODDESC;
  259.     c->next = NULL;
  260.     c->u.method = method;
  261.  
  262.     *component->constants_tail = c;
  263.     component->constants_tail = &c->next;
  264.  
  265.     return component->nconstants++;
  266. }
  267.  
  268.  
  269. /* Debug info. */
  270.  
  271. static void finish_debug_info(struct component *component)
  272. {
  273.     int cur_pc = current_position(component);    
  274.  
  275.     if (cur_pc != component->cur_line_start) {
  276.     struct debug_info *new = malloc(sizeof(*new));
  277.     new->line = component->cur_line;
  278.     new->scope = component->cur_scope;
  279.     new->bytes = cur_pc - component->cur_line_start;
  280.     new->next = NULL;
  281.     component->ndebug_infos++;
  282.     *component->debug_info_tail = new;
  283.     component->debug_info_tail = &new->next;
  284.     component->cur_line_start = cur_pc;
  285.     }
  286. }
  287.  
  288. static void set_line(struct component *component, int line)
  289. {
  290.     if (line != 0 && line != component->cur_line) {
  291.     finish_debug_info(component);
  292.     component->cur_line = line;
  293.     }
  294. }
  295.  
  296. static struct scope_info *make_scope(void)
  297. {
  298.     struct scope_info *res = malloc(sizeof(*res));
  299.  
  300.     res->handle = -1;
  301.     res->nvars = 0;
  302.     res->vars = NULL;
  303.     res->vars_tail = &res->vars;
  304.     res->outer = NULL;
  305.  
  306.     return res;
  307. }
  308.  
  309. static void add_var_info(struct scope_info *scope, struct id *var,
  310.              boolean indirect, boolean argument, int offset)
  311. {
  312.     struct var_info *var_info;
  313.  
  314.     if (var->internal)
  315.     return;
  316.  
  317.     var_info = malloc(sizeof(*var_info));
  318.     var_info->var = var;
  319.     var_info->indirect = indirect;
  320.     var_info->argument = argument;
  321.     var_info->offset = offset;
  322.     var_info->next = NULL;
  323.  
  324.     scope->nvars++;
  325.     *scope->vars_tail = var_info;
  326.     scope->vars_tail = &var_info->next;
  327. }
  328.  
  329. static void push_scope(struct component *component, struct scope_info *scope)
  330. {
  331.     if (scope->vars != NULL) {
  332.     finish_debug_info(component);
  333.     scope->outer = component->cur_scope;
  334.     component->cur_scope = scope;
  335.     }
  336. }
  337.  
  338. static void pop_scope(struct component *component, struct scope_info *scope)
  339. {
  340.     if (scope->vars != NULL) {
  341.     if (component->cur_scope != scope)
  342.         lose("popping wrong scope?");
  343.     finish_debug_info(component);
  344.     component->cur_scope = scope->outer;
  345.     }
  346. }
  347.  
  348.  
  349. /* Method creation */
  350.  
  351. static void compile_method_ref(struct method *method,
  352.                    struct component *component,
  353.                    int want)
  354. {
  355.     struct method *home = method->parent;
  356.     struct closes_over *over;
  357.  
  358.     method->component = compile_method(method);
  359.  
  360.     set_line(component, method->line);
  361.  
  362.     for (over = method->closes_over; over != NULL; over = over->next) {
  363.     struct binding *binding = over->binding;
  364.  
  365.     if (over->over)
  366.         emit_op_and_arg(component, op_PUSH_ARG, over->over->offset);
  367.     else if (binding->argument)
  368.         emit_op_and_arg(component, op_PUSH_ARG,
  369.                 home->nargs - binding->offset - 1);
  370.     else
  371.         emit_op_and_arg(component, op_PUSH_LOCAL, binding->offset);
  372.     }
  373.     
  374.     emit_op_and_arg(component, op_PUSH_CONSTANT,
  375.               find_method_desc(component, method));
  376.     compile_expr(method->specializers, component, SINGLE);
  377.  
  378.     if (method->rettypes) {
  379.     compile_expr(method->rettypes->req_types_list, component, SINGLE);
  380.     if (method->rettypes->rest_temp_varref)
  381.         compile_expr(method->rettypes->rest_temp_varref, component,SINGLE);
  382.     else if (method->rettypes->restp)
  383.         emit_op(component, op_PUSH_TRUE);
  384.     else
  385.         emit_op(component, op_PUSH_FALSE);
  386.     }
  387.     else {
  388.     emit_op(component, op_PUSH_NIL);
  389.     emit_op(component, op_PUSH_TRUE);
  390.     }
  391.  
  392.     emit_op(component, op_MAKE_METHOD);
  393.     canonicalize_value(component, want);
  394. }
  395.  
  396.  
  397. /* Expression compilers */
  398.  
  399. static void compile_varref_expr(struct varref_expr *expr,
  400.                 struct component *component,
  401.                 int want)
  402. {
  403.     struct binding *binding = expr->binding;
  404.  
  405.     set_line(component, expr->var->line);
  406.  
  407.     if (binding) {
  408.     if (want == NOTHING)
  409.         return;
  410.     if (binding->home != expr->home)
  411.         /* It is a closure var. */
  412.         emit_op_and_arg(component, op_PUSH_ARG, expr->over->offset);
  413.     else if (binding->argument)
  414.         emit_op_and_arg(component, op_PUSH_ARG,
  415.                 binding->home->nargs - binding->offset - 1);
  416.     else
  417.         emit_op_and_arg(component, op_PUSH_LOCAL, binding->offset);
  418.     if (binding->closed_over && binding->set)
  419.         emit_op(component, op_VALUE_CELL_REF);
  420.     if (!(want == FUNC && binding->function))
  421.         canonicalize_value(component, want);
  422.     }
  423.     else if (want == FUNC)
  424.     emit_op_and_arg(component, op_PUSH_FUNCTION,
  425.             find_variable(component, expr->var, FALSE));
  426.     else {
  427.     emit_op_and_arg(component, op_PUSH_VALUE,
  428.             find_variable(component, expr->var, FALSE));
  429.     if (want != FUNC)
  430.         canonicalize_value(component, want);
  431.     }
  432. }
  433.  
  434. static void compile_literal_expr(struct literal_expr *expr,
  435.                  struct component *component,
  436.                  int want)
  437. {
  438.     struct literal *lit = expr->lit;
  439.  
  440.     if (want == NOTHING)
  441.     return;
  442.  
  443.     set_line(component, lit->line);
  444.  
  445.     switch (lit->kind) {
  446.       case literal_TRUE:
  447.     emit_op(component, op_PUSH_TRUE);
  448.     break;
  449.       case literal_FALSE:
  450.     emit_op(component, op_PUSH_FALSE);
  451.     break;
  452.       case literal_UNBOUND:
  453.     emit_op(component, op_PUSH_UNBOUND);
  454.     break;
  455.       case literal_INTEGER:
  456.     {
  457.         struct integer_literal *l = (struct integer_literal *)lit;
  458.         if (-128 < l->value && l->value < 128) {
  459.         emit_op(component, op_PUSH_BYTE);
  460.         emit_byte(component, l->value & 0xff);
  461.         }
  462.         else {
  463.         emit_op(component, op_PUSH_INT);
  464.         emit_4bytes(component, (unsigned)l->value);
  465.         }
  466.         break;
  467.     }
  468.     
  469.       case literal_LIST:
  470.     if (((struct list_literal *)lit)->first == NULL) {
  471.         emit_op(component, op_PUSH_NIL);
  472.         break;
  473.     }
  474.     /* otherwise, drop though. */
  475.  
  476.       default:
  477.     emit_op_and_arg(component, op_PUSH_CONSTANT,
  478.               find_literal(component, lit));
  479.     break;
  480.     }
  481.  
  482.     canonicalize_value(component, want);
  483. }
  484.  
  485. static void compile_call(struct call_expr *expr,
  486.              struct component *component,
  487.              int want)
  488. {
  489.     struct argument *arg;
  490.     int nargs = 0;
  491.  
  492.     compile_expr(expr->func, component, FUNC);
  493.     for (arg = expr->args; arg != NULL; arg = arg->next) {
  494.     compile_expr(arg->expr, component, SINGLE);
  495.     nargs++;
  496.     }
  497.     if (want == TAIL)
  498.     emit_op_and_arg(component, op_CALL_TAIL, nargs);
  499.     else if (want == FUNC) {
  500.     emit_call_op_and_arg(component, op_CALL_FOR_SINGLE, nargs);
  501.     emit_op(component, op_CHECK_TYPE_FUNCTION);
  502.     }
  503.     else if (want == SINGLE)
  504.     emit_call_op_and_arg(component, op_CALL_FOR_SINGLE, nargs);
  505.     else {
  506.     emit_call_op_and_arg(component, op_CALL_FOR_MANY, nargs);
  507.     emit_wants(component, want);
  508.     }
  509. }
  510.  
  511. static void compile_call_expr(struct call_expr *expr,
  512.                   struct component *component,
  513.                   int want)
  514. {
  515.     if (expr->info && expr->info->compile)
  516.     (*expr->info->compile)(expr, component, want);
  517.     else
  518.     compile_call(expr, component, want);
  519. }
  520.  
  521. static void compile_method_expr(struct method_expr *expr,
  522.                 struct component *component,
  523.                 int want)
  524. {
  525.     compile_method_ref(expr->method, component, want);
  526. }
  527.  
  528. static void compile_dot_expr(struct dot_expr *expr,
  529.                  struct component *component,
  530.                  int want)
  531. {
  532.     compile_expr(expr->arg, component, SINGLE);
  533.     compile_expr(expr->func, component, FUNC);
  534.  
  535.     if (want == TAIL)
  536.     emit_op(component, op_DOT_TAIL);
  537.     else if (want == FUNC) {
  538.     emit_op(component, op_DOT_FOR_SINGLE);
  539.     emit_op(component, op_CHECK_TYPE_FUNCTION);
  540.     }
  541.     else if (want == SINGLE)
  542.     emit_op(component, op_DOT_FOR_SINGLE);
  543.     else {
  544.     emit_op(component, op_DOT_FOR_MANY);
  545.     emit_wants(component, want);
  546.     }
  547. }
  548.  
  549. static void compile_body_expr(struct body_expr *expr,
  550.                   struct component *component,
  551.                   int want)
  552. {
  553.     compile_body(expr->body, component, want);
  554. }
  555.  
  556. static void compile_block_expr(struct block_expr *expr,
  557.                    struct component *component,
  558.                    int want)
  559. {
  560.     lose("block expr made it though expand?\n");
  561. }
  562.  
  563. static void compile_case_expr(struct case_expr *expr,
  564.                   struct component *component,
  565.                   int want)
  566. {
  567.     lose("case expr made it though expand?\n");
  568. }
  569.  
  570. static void compile_if_expr(struct if_expr *expr,
  571.                 struct component *component,
  572.                 int want)
  573. {
  574.     unsigned char *cond_branch_loc;
  575.     unsigned char *done_branch_loc = NULL;
  576.     int concequent_pos;
  577.     int alternate_pos;
  578.     int done_pos;
  579.  
  580.     compile_expr(expr->cond, component, SINGLE);
  581.     emit_op(component, op_CONDITIONAL_BRANCH);
  582.     cond_branch_loc = reserve_space(component, 4);
  583.     concequent_pos = current_position(component);
  584.     compile_body(expr->consequent, component, want);
  585.     if (want != TAIL) {
  586.     set_line(component, expr->else_line);
  587.     emit_op(component, op_BRANCH);
  588.     done_branch_loc = reserve_space(component, 4);
  589.     }
  590.     alternate_pos = current_position(component);
  591.     write_branch_displacement(cond_branch_loc, concequent_pos, alternate_pos);
  592.  
  593.     compile_body(expr->alternate, component, want);
  594.     if (want != TAIL) {
  595.     done_pos = current_position(component);
  596.     write_branch_displacement(done_branch_loc, alternate_pos, done_pos);
  597.     }
  598. }
  599.  
  600. static void compile_for_expr(struct for_expr *expr,
  601.                  struct component *component,
  602.                  int want)
  603. {
  604.     lose("for expr made it though expand?\n");
  605. }
  606.  
  607. static void compile_select_expr(struct select_expr *expr,
  608.                 struct component *component,
  609.                 int want)
  610. {
  611.     lose("select expr made it though expand?\n");
  612. }
  613.  
  614. static void compile_varset_expr(struct varset_expr *expr,
  615.                 struct component *component,
  616.                 int want)
  617. {
  618.     struct binding *binding = expr->binding;
  619.  
  620.     set_line(component, expr->var->line);
  621.  
  622.     if (want == FUNC)
  623.     compile_expr(expr->value, component, FUNC);
  624.     else
  625.     compile_expr(expr->value, component, SINGLE);
  626.     if (expr->type) {
  627.     compile_varref_expr(expr->type, component, SINGLE);
  628.     emit_op(component, op_CHECK_TYPE);
  629.     }
  630.  
  631.     if (binding) {
  632.     if (!binding->set)
  633.         lose("Compiling a varset expr for a binding that isn't set?");
  634.     if (want != NOTHING)
  635.         emit_op(component, op_DUP);
  636.     if (binding->home != expr->home) {
  637.         /* It is a closure var. */
  638.         emit_op_and_arg(component, op_PUSH_ARG, expr->over->offset);
  639.         emit_op(component, op_VALUE_CELL_SET);
  640.     }
  641.     else if (binding->closed_over) {
  642.         if (binding->argument)
  643.         emit_op_and_arg(component, op_PUSH_ARG,
  644.                 binding->home->nargs - binding->offset - 1);
  645.         else
  646.         emit_op_and_arg(component, op_PUSH_LOCAL, binding->offset);
  647.         emit_op(component, op_VALUE_CELL_SET);
  648.     }
  649.     else if (binding->argument)
  650.         emit_op_and_arg(component, op_POP_ARG,
  651.                 binding->home->nargs - binding->offset - 1);
  652.     else
  653.         emit_op_and_arg(component, op_POP_LOCAL, binding->offset);
  654.     }
  655.     else {
  656.     /* It is a reference to a global variable. */
  657.     if (want != NOTHING)
  658.         emit_op(component, op_DUP);
  659.     emit_op_and_arg(component, op_POP_VALUE,
  660.             find_variable(component, expr->var, TRUE));
  661.     }
  662.     if (want != FUNC && want != NOTHING)
  663.     canonicalize_value(component, want);
  664. }
  665.  
  666. static void compile_binop_series_expr(struct binop_series_expr *expr,
  667.                       struct component *component,
  668.                       int want)
  669. {
  670.     lose("binop_series expr made it though expand?\n");
  671. }
  672.  
  673. static void compile_loop_expr(struct loop_expr *expr,
  674.                   struct component *component,
  675.                   int want)
  676. {
  677.     expr->position = current_position(component);
  678.     compile_body(expr->body, component, want);
  679. }
  680.  
  681. static void compile_repeat_expr(struct repeat_expr *expr,
  682.                 struct component *component,
  683.                 int want)
  684. {
  685.     emit_op(component, op_BRANCH);
  686.     write_branch_displacement(reserve_space(component, 4),
  687.                   current_position(component),
  688.                   expr->loop->position);
  689. }
  690.  
  691. static void compile_error_expr(struct expr *expr, struct component *component,
  692.                    int want)
  693. {
  694.     lose("Called compile on a parse tree with errors?");
  695. }
  696.  
  697. static void (*ExpressionCompilers[])() = {
  698.     compile_varref_expr, compile_literal_expr, compile_call_expr,
  699.     compile_method_expr, compile_dot_expr, compile_body_expr,
  700.     compile_block_expr, compile_case_expr, compile_if_expr, compile_for_expr,
  701.     compile_select_expr, compile_varset_expr, compile_binop_series_expr,
  702.     compile_loop_expr, compile_repeat_expr, compile_error_expr
  703. };
  704.  
  705. static void compile_expr(struct expr *expr, struct component *component,
  706.              int want)
  707. {
  708.     if (expr->analized)
  709.     (*ExpressionCompilers[(int)expr->kind])(expr, component, want);
  710.     else
  711.     lose("Compiling an expression that was never analized?");
  712. }
  713.  
  714.  
  715. /* Constituent compilers */
  716.  
  717. static void compile_defconst_constituent(struct defconst_constituent *c,
  718.                      struct component *component,
  719.                      int want)
  720. {
  721.     lose("define constant not at top-level?");
  722. }
  723.  
  724. static void compile_defvar_constituent(struct defvar_constituent *c,
  725.                        struct component *component,
  726.                        int want)
  727. {
  728.     lose("define variable not at top-level?");
  729. }
  730.  
  731. static void compile_defmethod_constituent(struct defmethod_constituent *c,
  732.                       struct component *component,
  733.                       int want)
  734. {
  735.     lose("define method not at top-level?");
  736. }
  737.  
  738. static void compile_defgeneric_constituent(struct defgeneric_constituent *c,
  739.                        struct component *component,
  740.                        int want)
  741. {
  742.     lose("define generic not at top-level?");
  743. }
  744.  
  745. static void compile_defclass_constituent(struct defclass_constituent *c,
  746.                      struct component *component,
  747.                      int want)
  748. {
  749.     lose("define class not at top-level?");
  750. }
  751.  
  752. static void compile_expr_constituent(struct expr_constituent *c,
  753.                      struct component *component,
  754.                      int want)
  755. {
  756.     compile_expr(c->expr, component, want);
  757. }
  758.  
  759. static void compile_local_constituent(struct local_constituent *c,
  760.                       struct component *component,
  761.                       int want)
  762. {
  763.     struct method *method;
  764.     struct binding *binding;
  765.     struct scope_info *scope = make_scope();
  766.  
  767.     for (method = c->methods, binding = c->lexenv->bindings;
  768.      method != NULL;
  769.      method = method->next_local, binding = binding->next) {
  770.     if (binding->argument)
  771.         lose("argument in the bindings of a local?");
  772.     if (binding->closed_over) {
  773.         emit_op(component, op_PUSH_FALSE);
  774.         emit_op(component, op_MAKE_VALUE_CELL);
  775.         emit_op_and_arg(component, op_POP_LOCAL, binding->offset);
  776.     }
  777.     add_var_info(scope, binding->id, binding->closed_over, FALSE,
  778.              binding->offset);
  779.     }
  780.  
  781.     push_scope(component, scope);
  782.  
  783.     for (method = c->methods, binding = c->lexenv->bindings;
  784.      method != NULL;
  785.      method = method->next_local, binding = binding->next) {
  786.     compile_method_ref(method, component, SINGLE);
  787.     if (binding->closed_over) {
  788.         emit_op_and_arg(component, op_PUSH_LOCAL, binding->offset);
  789.         emit_op(component, op_VALUE_CELL_SET);
  790.     }
  791.     else
  792.         emit_op_and_arg(component, op_POP_LOCAL, binding->offset);
  793.     }
  794.  
  795.     compile_body(c->body, component, want);
  796.  
  797.     pop_scope(component, scope);
  798. }
  799.  
  800. static void compile_handler_constituent(struct handler_constituent *c,
  801.                     struct component *component,
  802.                     int want)
  803. {
  804.     if (want == TAIL) {
  805.     emit_op_and_arg(component, op_PUSH_FUNCTION,
  806.             find_variable(component, id(sym_Apply), FALSE));
  807.     emit_op_and_arg(component, op_PUSH_FUNCTION,
  808.             find_variable(component, id(sym_Values), FALSE));
  809.     compile_handler_constituent(c, component, make_want(0, TRUE));
  810.     emit_op_and_arg(component, op_CALL_TAIL, 2);
  811.     }
  812.     else {
  813.     compile_body(c->body, component, want);
  814.     emit_op_and_arg(component, op_PUSH_FUNCTION,
  815.             find_variable(component, id(sym_PopHandler),
  816.                       FALSE));
  817.     emit_call_op_and_arg(component, op_CALL_FOR_MANY, 0);
  818.     emit_wants(component, NOTHING);
  819.     }
  820. }
  821.  
  822. static void compile_let_constituent(struct let_constituent *c,
  823.                     struct component *component,
  824.                     int want)
  825. {
  826.     struct bindings *bindings = c->bindings;
  827.     struct binding *binding = c->lexenv->bindings;
  828.     struct scope_info *scope = make_scope();
  829.  
  830.     compile_expr(bindings->expr, component,
  831.          make_want(c->required, bindings->params->rest_param));
  832.     while (binding != c->inside) {
  833.     boolean indirect = binding->set && binding->closed_over;
  834.     if (indirect)
  835.         emit_op(component, op_MAKE_VALUE_CELL);
  836.     emit_op_and_arg(component, op_POP_LOCAL, binding->offset);
  837.     if (binding->argument)
  838.         lose("Argument in the bindings of a let?");
  839.     add_var_info(scope, binding->id, indirect, FALSE, binding->offset);
  840.     binding = binding->next;
  841.     }
  842.     push_scope(component, scope);
  843.     compile_body(c->body, component, want);
  844.     pop_scope(component, scope);
  845. }
  846.  
  847. static void compile_tlf_constituent(struct tlf_constituent *c,
  848.                     struct component *component,
  849.                     int want)
  850. {
  851.     lose("top-level-form not at top-level?");
  852. }
  853.  
  854. static void compile_error_constituent(struct constituent *c,
  855.                       struct component *component,
  856.                       int want)
  857. {
  858.     lose("called compile on a parse tree with errors?");
  859. }
  860.  
  861. static void compile_defmodule_constituent(struct defnamespace_constituent *c,
  862.                       struct component *component,
  863.                       int want)
  864. {
  865.     lose("define module not at top-level?");
  866. }
  867.  
  868. static void compile_deflibrary_constituent(struct defnamespace_constituent *c,
  869.                        struct component *component,
  870.                        int want)
  871. {
  872.     lose("define library not at top-level?");
  873. }
  874.  
  875. static void (*ConstituentCompilers[])() = {
  876.     compile_defconst_constituent, compile_defvar_constituent,
  877.     compile_defmethod_constituent, compile_defgeneric_constituent,
  878.     compile_defclass_constituent, compile_expr_constituent,
  879.     compile_local_constituent, compile_handler_constituent,
  880.     compile_let_constituent, compile_tlf_constituent,
  881.     compile_error_constituent, compile_defmodule_constituent,
  882.     compile_deflibrary_constituent
  883. };
  884.  
  885. static void compile_constituent(struct constituent *c,
  886.                 struct component *component, int want)
  887. {
  888.     (*ConstituentCompilers[(int)c->kind])(c, component, want);
  889. }
  890.  
  891.  
  892. /* Body compiler */
  893.  
  894. static void compile_body(struct body *body, struct component *component,
  895.              int want)
  896. {
  897.     struct constituent *c, *next;
  898.  
  899.     for (c = body->head; (next = c->next) != NULL; c = next)
  900.     compile_constituent(c, component, 0);
  901.     compile_constituent(c, component, want);
  902. }
  903.  
  904.  
  905. /* Compile-method */
  906.  
  907. static struct component *compile_method(struct method *method)
  908. {
  909.     struct component *component = malloc(sizeof(struct component));
  910.     struct binding *binding;
  911.     struct scope_info *scope = make_scope();
  912.     struct closes_over *over;
  913.  
  914.     component->debug_name = method->debug_name;
  915.     component->frame_size = method->frame_size;
  916.     component->cur_line = method->line;
  917.     component->cur_scope = NULL;
  918.     component->cur_line_start = 0;
  919.     component->ndebug_infos = 0;
  920.     component->debug_info = NULL;
  921.     component->debug_info_tail = &component->debug_info;
  922.     component->nconstants = 0;
  923.     component->constants = NULL;
  924.     component->constants_tail = &component->constants;
  925.     component->bytes = 0;
  926.     component->blocks = NULL;
  927.     component->cur_block = NULL;
  928.     component->fill = NULL;
  929.     component->end = NULL;
  930.  
  931.     set_line(component, method->line);
  932.  
  933.     for (over = method->closes_over; over != NULL; over = over->next) {
  934.     binding = over->binding;
  935.     add_var_info(scope, binding->id, binding->set, TRUE, over->offset);
  936.     }
  937.  
  938.     for (binding = method->lexenv->bindings;
  939.      binding != NULL && binding->home == method;
  940.      binding = binding->next) {
  941.     boolean indirect = binding->set && binding->closed_over;
  942.     if (indirect) {
  943.         emit_op_and_arg(component, op_PUSH_ARG,
  944.                 method->nargs - binding->offset - 1);
  945.         emit_op(component, op_MAKE_VALUE_CELL);
  946.         emit_op_and_arg(component, op_POP_ARG,
  947.                 method->nargs - binding->offset - 1);
  948.     }
  949.     if (!binding->argument)
  950.         lose("Non-argument in the method bindings?");
  951.     add_var_info(scope, binding->id, indirect, TRUE,
  952.              method->nargs - binding->offset - 1);
  953.     }
  954.  
  955.     push_scope(component, scope);
  956.  
  957.     compile_body(method->body, component, TAIL);
  958.  
  959.     pop_scope(component, scope);
  960.     finish_debug_info(component);
  961.  
  962.     component->cur_block->end = component->fill;
  963.     component->bytes += component->fill - component->cur_block->bytes;
  964.     component->fill = NULL;
  965.     component->end = NULL;
  966.     component->cur_block = NULL;
  967.  
  968.     return component;
  969. }
  970.  
  971.  
  972. /* Top Level Constituent compilers */
  973.  
  974. static void compile_tl_defconst_constituent(struct defconst_constituent *c)
  975. {
  976.     dump_defconst(c->bindings->params, compile_method(c->tlf));
  977. }
  978.  
  979. static void compile_tl_defvar_constituent(struct defvar_constituent *c)
  980. {
  981.     dump_defvar(c->bindings->params, compile_method(c->tlf));
  982. }
  983.  
  984. static void compile_tl_defmethod_constituent(struct defmethod_constituent *c)
  985. {
  986.     dump_defmethod(c->method->name, compile_method(c->tlf));
  987. }
  988.  
  989. static void compile_tl_defgeneric_constituent(struct defgeneric_constituent *c)
  990. {
  991.     dump_defgeneric(c->name, compile_method(c->tlf));
  992. }
  993.  
  994. static void compile_tl_defclass_constituent(struct defclass_constituent *c)
  995. {
  996.     dump_defclass(c->name, c->slots,
  997.           compile_method(c->tlf1),
  998.           compile_method(c->tlf2));
  999. }
  1000.  
  1001. static void compile_tl_expr_constituent(struct expr_constituent *c)
  1002. {
  1003.     struct expr *expr = c->expr;
  1004.  
  1005.     if (expr->kind == expr_BODY) {
  1006.     struct body_expr *body_expr = (struct body_expr *)expr;
  1007.     compile_tl_body(body_expr->body);
  1008.     }
  1009.     else
  1010.     lose("expression constituent at top-level?");
  1011. }
  1012.  
  1013. static void compile_tl_local_constituent(struct local_constituent *c)
  1014. {
  1015.     lose("local constituent at top-level?");
  1016. }
  1017.  
  1018. static void compile_tl_handler_constituent(struct handler_constituent *c)
  1019. {
  1020.     lose("handler constituent made it through expand?\n");
  1021. }
  1022.  
  1023. static void compile_tl_let_constituent(struct let_constituent *c)
  1024. {
  1025.     lose("let constituent at top-level?");
  1026. }
  1027.  
  1028. static void compile_tl_tlf_constituent(struct tlf_constituent *c)
  1029. {
  1030.     dump_top_level_form(compile_method(c->form));
  1031. }
  1032.  
  1033. static void compile_tl_error_constituent(struct constituent *c)
  1034. {
  1035.     lose("called compile on a parse tree with errors?");
  1036. }
  1037.  
  1038. static void compile_tl_defmodule_constituent(struct defnamespace_constituent*c)
  1039. {
  1040.     dump_defmodule(c);
  1041. }
  1042.  
  1043. static void
  1044.     compile_tl_deflibrary_constituent(struct defnamespace_constituent *c)
  1045. {
  1046.     dump_deflibrary(c);
  1047. }
  1048.  
  1049.  
  1050. static void (*TLConstituentCompilers[])() = {
  1051.     compile_tl_defconst_constituent, compile_tl_defvar_constituent,
  1052.     compile_tl_defmethod_constituent, compile_tl_defgeneric_constituent,
  1053.     compile_tl_defclass_constituent, compile_tl_expr_constituent,
  1054.     compile_tl_local_constituent, compile_tl_handler_constituent,
  1055.     compile_tl_let_constituent, compile_tl_tlf_constituent,
  1056.     compile_tl_error_constituent, compile_tl_defmodule_constituent,
  1057.     compile_tl_deflibrary_constituent
  1058. };
  1059.  
  1060. static void compile_tl_constituent(struct constituent *c)
  1061. {
  1062.     (*TLConstituentCompilers[(int)c->kind])(c);
  1063. }
  1064.  
  1065. static void compile_tl_body(struct body *body)
  1066. {
  1067.     struct constituent *c;
  1068.  
  1069.     for (c = body->head; c != NULL; c = c->next)
  1070.     compile_tl_constituent(c);
  1071. }
  1072.  
  1073.  
  1074. /* Compile */
  1075.  
  1076. void compile(struct body *program)
  1077. {
  1078.     compile_tl_body(program);
  1079. }
  1080.  
  1081.  
  1082. /* Compilers for various magic functions */
  1083.  
  1084. static void compile_binary_call(struct call_expr *call,
  1085.                 struct component *component,
  1086.                 int want,
  1087.                 int op)
  1088. {
  1089.     struct argument *args = call->args;
  1090.  
  1091.     if (args && args->next && args->next->next == NULL) {
  1092.     compile_expr(args->expr, component, SINGLE);
  1093.     compile_expr(args->next->expr, component, SINGLE);
  1094.     emit_op(component, op);
  1095.     canonicalize_value(component, want);
  1096.     }
  1097.     else {
  1098.     struct varref_expr *func = (struct varref_expr *)call->func;
  1099.     warn(func->var->line, "%s called with other than two arguments",
  1100.          func->var->symbol->name);
  1101.     compile_call(call, component, want);
  1102.     }
  1103. }    
  1104.  
  1105. static void compile_check_type_call(struct call_expr *call,
  1106.                     struct component *component,
  1107.                     int want)
  1108. {
  1109.     compile_binary_call(call, component, want, op_CHECK_TYPE);
  1110. }
  1111.  
  1112. static void compile_plus_call(struct call_expr *call,
  1113.                   struct component *component,
  1114.                   int want)
  1115. {
  1116.     compile_binary_call(call, component, want, op_PLUS);
  1117. }
  1118.  
  1119. static void compile_minus_call(struct call_expr *call,
  1120.                    struct component *component,
  1121.                    int want)
  1122. {
  1123.     compile_binary_call(call, component, want, op_MINUS);
  1124. }
  1125.  
  1126. static void compile_lt_call(struct call_expr *call,
  1127.                   struct component *component,
  1128.                   int want)
  1129. {
  1130.     compile_binary_call(call, component, want, op_LT);
  1131. }
  1132.  
  1133. static void compile_le_call(struct call_expr *call,
  1134.                   struct component *component,
  1135.                   int want)
  1136. {
  1137.     compile_binary_call(call, component, want, op_LE);
  1138. }
  1139.  
  1140. static void compile_eq_call(struct call_expr *call,
  1141.                   struct component *component,
  1142.                   int want)
  1143. {
  1144.     compile_binary_call(call, component, want, op_EQ);
  1145. }
  1146.  
  1147. static void compile_idp_call(struct call_expr *call,
  1148.                   struct component *component,
  1149.                   int want)
  1150. {
  1151.     compile_binary_call(call, component, want, op_IDP);
  1152. }
  1153.  
  1154. static void compile_ne_call(struct call_expr *call,
  1155.                   struct component *component,
  1156.                   int want)
  1157. {
  1158.     compile_binary_call(call, component, want, op_NE);
  1159. }
  1160.  
  1161. static void compile_ge_call(struct call_expr *call,
  1162.                   struct component *component,
  1163.                   int want)
  1164. {
  1165.     compile_binary_call(call, component, want, op_GE);
  1166. }
  1167.  
  1168. static void compile_gt_call(struct call_expr *call,
  1169.                   struct component *component,
  1170.                   int want)
  1171. {
  1172.     compile_binary_call(call, component, want, op_GT);
  1173. }
  1174.  
  1175. static void compile_values_call(struct call_expr *call,
  1176.                 struct component *component,
  1177.                 int want)
  1178. {
  1179.     struct argument *args = call->args;
  1180.  
  1181.     if (want == TAIL) {
  1182.     if (args != NULL && args->next == NULL) {
  1183.         compile_expr(args->expr, component, SINGLE);
  1184.         emit_op(component, op_RETURN_SINGLE);
  1185.     }
  1186.     else
  1187.         compile_call(call, component, want);
  1188.     }
  1189.     else if (want == FUNC) {
  1190.     if (args) {
  1191.         compile_expr(args->expr, component, FUNC);
  1192.         while ((args = args->next) != NULL)
  1193.         compile_expr(args->expr, component, NOTHING);
  1194.     }
  1195.     else {
  1196.         struct varref_expr *func = (struct varref_expr *)call->func;
  1197.         warn(func->var->line, "%s called with zero arguments in a "
  1198.          "for-function context",
  1199.          func->var->symbol->name);
  1200.         emit_op(component, op_PUSH_FALSE);
  1201.         emit_op(component, op_CHECK_TYPE_FUNCTION);
  1202.     }
  1203.     }
  1204.     else if (want_restp(want))
  1205.     compile_call(call, component, want);
  1206.     else {
  1207.     int fixed = want_req(want);
  1208.     int i;
  1209.  
  1210.     for (i = 0; i < fixed && args != NULL; i++) {
  1211.         compile_expr(args->expr, component, SINGLE);
  1212.         args = args->next;
  1213.     }
  1214.     if (args == NULL)
  1215.         for (; i < fixed; i++)
  1216.         emit_op(component, op_PUSH_FALSE);
  1217.     else {
  1218.         while (args != NULL) {
  1219.         compile_expr(args->expr, component, NOTHING);
  1220.         args = args->next;
  1221.         }
  1222.     }
  1223.     }
  1224. }
  1225.  
  1226. static void compile_find_variable_call(struct call_expr *call,
  1227.                        struct component *component,
  1228.                        int want)
  1229. {
  1230.     struct argument *args = call->args;
  1231.  
  1232.     if (args && args->next == NULL) {
  1233.     struct varref_expr *expr = (struct varref_expr *)args->expr;
  1234.  
  1235.     if (expr->kind != expr_VARREF)
  1236.         lose("find-variable called on something other than a variable?");
  1237.     if (expr->binding)
  1238.         lose("find-variable called on a local variable?");
  1239.     emit_op_and_arg(component, op_PUSH_CONSTANT,
  1240.             find_variable(component, expr->var, FALSE));
  1241.     canonicalize_value(component, want);
  1242.     }
  1243.     else
  1244.     lose("find-variable called with the wrong number of arguments?");
  1245. }
  1246.  
  1247. static void set_compiler(char *name, void (*compiler)(), boolean internal)
  1248. {
  1249.     struct id *identifier = id(symbol(name));
  1250.     struct function_info *info;
  1251.  
  1252.     identifier->internal = internal;
  1253.     info = lookup_function_info(identifier, TRUE);
  1254.     info->compile = compiler;
  1255.  
  1256.     free(identifier);
  1257. }
  1258.  
  1259. void init_compile(void)
  1260. {
  1261.     set_compiler("check-type", compile_check_type_call, TRUE);
  1262.     set_compiler("check-type", compile_check_type_call, FALSE);
  1263.     set_compiler("+", compile_plus_call, TRUE);
  1264.     set_compiler("+", compile_plus_call, FALSE);
  1265.     set_compiler("-", compile_minus_call, TRUE);
  1266.     set_compiler("-", compile_minus_call, FALSE);
  1267.     set_compiler("<", compile_lt_call, TRUE);
  1268.     set_compiler("<", compile_lt_call, FALSE);
  1269.     set_compiler("<=", compile_le_call, TRUE);
  1270.     set_compiler("<=", compile_le_call, FALSE);
  1271.     set_compiler("=", compile_eq_call, TRUE);
  1272.     set_compiler("=", compile_eq_call, FALSE);
  1273.     set_compiler("==", compile_idp_call, TRUE);
  1274.     set_compiler("==", compile_idp_call, FALSE);
  1275.     set_compiler("~=", compile_ne_call, TRUE);
  1276.     set_compiler("~=", compile_ne_call, FALSE);
  1277.     set_compiler(">", compile_gt_call, TRUE);
  1278.     set_compiler(">", compile_gt_call, FALSE);
  1279.     set_compiler(">=", compile_ge_call, TRUE);
  1280.     set_compiler(">=", compile_ge_call, FALSE);
  1281.     set_compiler("values", compile_values_call, TRUE);
  1282.     set_compiler("values", compile_values_call, FALSE);
  1283.     set_compiler("find-variable", compile_find_variable_call, TRUE);
  1284. }
  1285.